home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / printers / print-types.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.7 KB  |  202 lines  |  [TEXT/CCL2]
  1. ;;; print-types.scm -- print type-related AST structures
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  15 Jan 1991
  5. ;;;
  6. ;;; This file corresponds to the stuff in ast/type-structs.scm
  7. ;;;
  8.  
  9. (define-ast-printer tyvar (object xp)
  10.   (write-avarid (tyvar-name object) xp))
  11.  
  12.  
  13. ;;; Various type special cases have a magic cookie in the def field.
  14.  
  15. (define-ast-printer tycon (object xp)
  16.   (print-general-tycon (tycon-def object) (tycon-args object) object xp))
  17.  
  18. (define (print-general-tycon def args object xp)
  19.     (cond ((eq? def (core-symbol "Arrow"))
  20.        (write-arrow-tycon args xp))
  21.       ((eq? def (core-symbol "UnitType"))
  22.        (write-unit-tycon xp))
  23.       ((eq? def (core-symbol "List"))
  24.        (write-list-tycon args xp))
  25.       ((is-tuple-tycon? def)
  26.        (write-tuple-tycon args xp))
  27.       (else
  28.        (write-ordinary-tycon def args object xp))))
  29.  
  30. (define (write-arrow-tycon args xp)
  31.   (with-ast-block (xp)
  32.     (write-btype (car args) xp)
  33.     (write-string " ->" xp)
  34.     (write-whitespace xp)
  35.     (write (cadr args) xp)))
  36.  
  37. (define (write-unit-tycon xp)
  38.   (write-string "()" xp))
  39.  
  40. (define (write-list-tycon args xp)
  41.   (with-ast-block (xp)
  42.     (write-char #\[ xp)
  43.     (write (car args) xp)
  44.     (write-char #\] xp)))
  45.  
  46. (define (write-tuple-tycon args xp)
  47.   (write-commaized-list args xp))
  48.  
  49. (define (write-ordinary-tycon def args object xp)
  50.   (with-ast-block (xp)
  51.     (if (tycon? object)
  52.     (write-tyconid (tycon-name object) xp)
  53.     (write-tyconid (def-name def) xp))
  54.     (when (not (null? args))
  55.       (write-whitespace xp)
  56.       (write-delimited-list
  57.         args xp (function write-atype) "" "" ""))))
  58.  
  59.  
  60. ;;; All of the special cases above except "Arrow" are atypes, as is
  61. ;;; a tyvar or a tycon with no arguments.
  62.  
  63. (define (write-atype object xp)
  64.  (let ((object (maybe-prune object)))
  65.   (if (or (tyvar? object)
  66.       (gtyvar? object)
  67.       (ntyvar? object)
  68.       (is-some-tycon? object
  69.          (lambda (def)
  70.            (or (eq? def (core-symbol "UnitType"))
  71.            (eq? def (core-symbol "List"))
  72.            (is-tuple-tycon? def)))))
  73.       (write object xp)
  74.       (begin
  75.         (write-char #\( xp)
  76.     (write object xp)
  77.     (write-char #\) xp)))))
  78.  
  79.  
  80. ;;; A btype is any type except the arrow tycon.
  81.  
  82. (define (write-btype object xp)
  83.  (let ((object (maybe-prune object)))
  84.   (if (or (and (tycon? object)
  85.            (eq? (tycon-def object) (core-symbol "Arrow")))
  86.       (and (ntycon? object)
  87.            (eq? (ntycon-tycon object) (core-symbol "Arrow"))))
  88.       (begin
  89.         (write-char #\( xp)
  90.     (write object xp)
  91.     (write-char #\) xp))
  92.       (write object xp))))
  93.       
  94. (define (maybe-prune object)
  95.   (if (ntyvar? object)
  96.       (prune object)
  97.       object))
  98.  
  99. (define (is-some-tycon? object fn)
  100.   (let ((object (maybe-prune object)))
  101.     (or (and (tycon? object)
  102.          (or (null? (tycon-args object))
  103.          (funcall fn (tycon-def object))))
  104.     (and (ntycon? object)
  105.          (or (null? (ntycon-args object))
  106.          (funcall fn (ntycon-tycon object)))))))
  107.  
  108. (define-ast-printer context (object xp)
  109.   (with-ast-block (xp)
  110.     (write (context-class object) xp)
  111.     (write-whitespace xp)
  112.     (write-avarid (context-tyvar object) xp)))
  113.  
  114. (define-ast-printer signature (object xp)
  115.   (write-contexts (signature-context object) xp)
  116.   (write (signature-type object) xp))
  117.  
  118. (define (write-contexts contexts xp)
  119.   (when (not (null? contexts))
  120.     (if (null? (cdr contexts))
  121.     (write (car contexts) xp)
  122.     (write-commaized-list contexts xp))
  123.     (write-string " =>" xp)
  124.     (write-whitespace xp)))
  125.  
  126. (define-ast-printer synonym-decl (object xp)
  127.   (with-ast-block (xp)
  128.     (write-string "type " xp)
  129.     (write (synonym-decl-simple object) xp)
  130.     (write-string " =" xp)
  131.     (write-whitespace xp)
  132.     (write (synonym-decl-body object) xp)))
  133.  
  134. (define-ast-printer data-decl (object xp)
  135.   (with-ast-block (xp)
  136.     (write-string "data " xp)
  137.     (write-contexts (data-decl-context object) xp)
  138.     (write (data-decl-simple object) xp)
  139.     (write-whitespace xp)
  140.     (write-char #\= xp)
  141.     (write-whitespace xp)
  142.     (write-delimited-list
  143.       (data-decl-constrs object) xp (function write) " |" "" "")
  144.     (write-whitespace xp)
  145.     (let ((deriving  (data-decl-deriving object)))
  146.       (when (not (null? deriving))
  147.     (write-string "deriving " xp)
  148.     (if (null? (cdr deriving))
  149.         (write (car deriving) xp)
  150.         (write-commaized-list deriving xp))))))
  151.  
  152. (define-ast-printer constr (object xp)
  153.   (if (con-ref-infix? (constr-constructor object))
  154.       (with-ast-block (xp)
  155.         (write-btype (car (constr-types object)) xp)
  156.     (write-whitespace xp)
  157.     (write (constr-constructor object) xp)
  158.     (write-whitespace xp)
  159.     (write-btype (cadr (constr-types object)) xp))
  160.       (with-ast-block (xp)
  161.     (write (constr-constructor object) xp)
  162.     (when (not (null? (constr-types object)))
  163.       (write-whitespace xp)
  164.       (write-delimited-list
  165.        (constr-types object) xp (function write-atype) "" "" "")))))
  166.  
  167.  
  168. (define-ast-printer class-decl (object xp)
  169.   (with-ast-block (xp)
  170.     (write-string "class " xp)
  171.     (write-contexts (class-decl-super-classes object) xp)
  172.     (write (class-decl-class object) xp)
  173.     (write-whitespace xp)
  174.     (write-avarid (class-decl-class-var object) xp)
  175.     (write-wheredecls (class-decl-decls object) xp)))
  176.  
  177. (define-ast-printer instance-decl (object xp)
  178.   (with-ast-block (xp)
  179.     (write-string "instance " xp)
  180.     (write-contexts (instance-decl-context object) xp)
  181.     (write (instance-decl-class object) xp)
  182.     (write-whitespace xp)
  183.     (write-atype (instance-decl-simple object) xp)
  184.     (write-wheredecls (instance-decl-decls object) xp)))
  185.  
  186.  
  187. ;;; Don't print out default decl if the value is the default.
  188.  
  189. (define-ast-printer default-decl (object xp)
  190.   (with-ast-block (xp)
  191.     (write-string "default " xp)
  192.     (let ((types  (default-decl-types object)))
  193.       (if (null? (cdr types))
  194.       (write (car types) xp)
  195.       (write-commaized-list types xp)))))
  196.  
  197. (define-ast-printer class-ref (object xp)
  198.   (write-tyclsid (class-ref-name object) xp))
  199.         
  200.   
  201.   
  202.